home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM 1995 Fall / PD-ROM F95.toast / Programming / Programming Languages / UCB Logo 3.0 ƒ / sources / standard source / parse.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-08-14  |  12.4 KB  |  506 lines  |  [TEXT/ttxt]
  1. /*
  2.  *      parse.c         logo parser module              dvb
  3.  *
  4.  *    Copyright (C) 1993 by the Regents of the University of California
  5.  *
  6.  *      This program is free software; you can redistribute it and/or modify
  7.  *      it under the terms of the GNU General Public License as published by
  8.  *      the Free Software Foundation; either version 2 of the License, or
  9.  *      (at your option) any later version.
  10.  *  
  11.  *      This program is distributed in the hope that it will be useful,
  12.  *      but WITHOUT ANY WARRANTY; without even the implied warranty of
  13.  *      MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14.  *      GNU General Public License for more details.
  15.  *  
  16.  *      You should have received a copy of the GNU General Public License
  17.  *      along with this program; if not, write to the Free Software
  18.  *      Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  *
  20.  */
  21.  
  22. #include "logo.h"
  23. #include "globals.h"
  24. #ifdef unix
  25. #include <sgtty.h>
  26. #endif
  27. #include <ctype.h>
  28. #ifdef ibm
  29. #include <bios.h>
  30. extern int getch(void);
  31. #endif
  32. #ifdef __ZTC__
  33. #include <disp.h>
  34. #endif
  35.  
  36. #ifndef TIOCSTI
  37. #include <setjmp.h>
  38. extern jmp_buf iblk_buf;
  39. #endif
  40.  
  41. FILE *readstream = stdin;
  42. FILE *writestream = stdout;
  43. FILE *loadstream = stdin;
  44. FILE *dribblestream = NULL;
  45. int input_blocking = 0;
  46.  
  47. int rd_getc(FILE *strm)
  48. {
  49.     int c;
  50.  
  51. #ifdef __ZTC__
  52.     if (strm == stdin) zflush();
  53.     c = ztc_getc(strm);
  54. #else
  55.     c = getc(strm);
  56. #endif
  57.     if (strm == stdin && c != EOF) update_coords(c);
  58. #ifdef ibm
  59.     if (c == 17 && interactive && strm==stdin) { /* control-q */
  60.     to_pending = 0;
  61.     err_logo(STOP_ERROR,NIL);
  62.     }
  63.     if (c == 23 && interactive && strm==stdin) { /* control-w */
  64. #ifndef __ZTC__
  65.     getc(strm); /* eat up the return */
  66. #endif
  67.     logo_pause();
  68.     return(rd_getc(strm));
  69.     }
  70. #endif
  71.     return(c);
  72. }
  73.  
  74. void rd_print_prompt(char *str)
  75. {
  76.     int ch;
  77.  
  78. #ifdef ibm
  79. #ifdef __ZTC__
  80.     if (in_graphics_mode && !in_splitscreen)
  81. #else
  82.     if (in_graphics_mode && ibm_screen_top == 0)
  83. #endif
  84.     lsplitscreen();
  85. #endif
  86.     ndprintf(stdout,"%t",str);
  87. #ifdef __ZTC__
  88.     zflush();
  89. #endif
  90. }
  91.  
  92. #ifdef __ZTC__
  93. void zrd_print_prompt(char *str) {
  94.     newline_bugfix();
  95.     rd_print_prompt(str);
  96. }
  97. #else
  98. #define zrd_print_prompt rd_print_prompt
  99. #endif
  100.  
  101. NODE *reader(FILE *strm, char *prompt)
  102. {
  103.     int c, dribbling, vbar = 0;
  104.     char *phys_line, p_line[MAX_PHYS_LINE];
  105.     NODETYPES this_type = STRING;
  106.     NODE *ret;
  107.  
  108.     charmode_off();
  109.     dribbling = (dribblestream != NULL && strm == stdin);
  110.     phys_line = p_line;
  111.     if (strm == stdin && *prompt) {
  112.     if (interactive) rd_print_prompt(prompt);
  113.     if (dribblestream != NULL)
  114.         fprintf(dribblestream, "%s", prompt);
  115.     }
  116.     if (strm == stdin) {
  117.     input_blocking++;
  118.     erract_errtype = FATAL;
  119.     }
  120.  
  121. #ifndef TIOCSTI
  122.     if (!setjmp(iblk_buf)) {
  123. #endif
  124.     c = rd_getc(strm);
  125.     while (c != EOF && (vbar || c != '\n')) {
  126.     if (dribbling) putc(c, dribblestream);
  127.     if (c == '\\' && (c = rd_getc(strm)) != EOF) {
  128.         if (dribbling) putc(c, dribblestream);
  129.         c = setparity(c);
  130.         this_type = BACKSLASH_STRING;
  131.         if (c == setparity('\n') && strm == stdin) {
  132.         if (interactive) zrd_print_prompt("\\ ");
  133.         if (dribbling)
  134.             fprintf(dribblestream, "\\ ");
  135.         }
  136.     }
  137.     if (c != EOF) *phys_line++ = c;
  138.     if (c == '|') vbar = !vbar;
  139.     if (/* vbar && */ c == '\n') {
  140.         if (strm == stdin) {
  141.         if (interactive) zrd_print_prompt("| ");
  142.         if (dribbling)
  143.             fprintf(dribblestream, "| ");
  144.         }
  145.     }
  146.     while (!vbar && c == '~' && (c = rd_getc(strm)) != EOF) {
  147.         while (c == ' ' || c == '\t')
  148.         c = rd_getc(strm);
  149.         if (dribbling) putc(c, dribblestream);
  150.         *phys_line++ = c;
  151.         if (c == '\n' && strm == stdin) {
  152.         if (interactive) zrd_print_prompt("~ ");
  153.         if (dribbling)
  154.             fprintf(dribblestream, "~ ");
  155.         }
  156.     }
  157.     if (c != EOF) c = rd_getc(strm);
  158.     }
  159. #ifndef TIOCSTI
  160.     }
  161. #endif
  162.     *phys_line = '\0';
  163.     input_blocking = 0;
  164. #ifdef __ZTC__
  165.     fix_cursor();
  166.     if (interactive && strm == stdin) newline_bugfix();
  167. #endif
  168.     if (dribbling)
  169.     putc('\n', dribblestream);
  170.     if (c == EOF && strm == stdin) {
  171.     if (interactive) clearerr(stdin);
  172.     rd_print_prompt("\n");
  173.     }
  174.     if (phys_line == p_line) return(Null_Word); /* so emptyp works */
  175.     ret = make_strnode(p_line, (char *)NULL, (int)strlen(p_line),
  176.                this_type, strnzcpy);
  177.     return(ret);
  178. }
  179.  
  180. NODE *list_to_array(NODE *list)
  181. {
  182.     NODE *np = list, *result;
  183.     int len = 0, i;
  184.  
  185.     for (; np; np = cdr(np)) len++;
  186.  
  187.     result = make_array(len);
  188.     setarrorg(result,1);
  189.  
  190.     for (i = 0, np = list; np; np = cdr(np))
  191.     (getarrptr(result))[i++] = vref(car(np));
  192.  
  193.     return(result);
  194. }
  195.  
  196. #define parens(ch)      (ch == '(' || ch == ')' || ch == ';')
  197. #define infixs(ch)      (ch == '*' || ch == '/' || ch == '+' || ch == '-' || ch == '=' || ch == '<' || ch == '>')
  198. #define white_space(ch) (ch == ' ' || ch == '\t')
  199.  
  200. NODE *parser_iterate(char **inln, char *inlimit, char *inhead,
  201.              BOOLEAN semi, int endchar)
  202. {
  203.     char ch, *wptr = NULL;
  204.     static char terminate = '\0';   /* KLUDGE */
  205.     NODE *outline = NIL, *lastnode = NIL, *tnode = NIL;
  206.     int windex = 0, vbar = 0;
  207.     NODETYPES this_type = STRING;
  208.     BOOLEAN broken = FALSE;
  209.  
  210.     do {
  211.     /* get the current character and increase pointer */
  212.     ch = **inln;
  213.     if (!vbar && windex == 0) wptr = *inln;
  214.     if (++(*inln) >= inlimit) *inln = &terminate;
  215.  
  216.     /* skip through comments and line continuations */
  217.     while (!vbar && ((semi && ch == ';') ||
  218.         (ch == '~' && **inln == '\n'))) {
  219.         while (ch == '~' && **inln == '\n') {
  220.         if (++(*inln) >= inlimit) *inln = &terminate;
  221.         ch = **inln;
  222.         if (windex == 0) wptr = *inln;
  223.         else {
  224.             if (**inln == ']' || **inln == '[' ||
  225.                          **inln == '{' || **inln == '}') {
  226.             ch = ' ';
  227.             break;
  228.             } else {
  229.             broken = TRUE;
  230.             }
  231.         }
  232.         if (++(*inln) >= inlimit) *inln = &terminate;
  233.         }
  234.  
  235.         if (semi && ch == ';')
  236.         do {
  237.             ch = **inln;
  238.             if (windex == 0) wptr = *inln;
  239.             else broken = TRUE;
  240.             if (++(*inln) >= inlimit) *inln = &terminate;
  241.         } while (ch != '\0' && ch != '~' && **inln != '\n');
  242.     }
  243.  
  244.     /* flag that this word will be of BACKSLASH_STRING type */
  245.     if (getparity(ch)) this_type = BACKSLASH_STRING;
  246.  
  247.     if (ch == '|') {
  248.         vbar = !vbar;
  249.         this_type = VBAR_STRING;
  250.         broken = TRUE; /* so we'll copy the chars */
  251.     }
  252.  
  253.     else if (vbar || (!white_space(ch) && ch != ']' &&
  254.             ch != '{' && ch != '}' &&
  255.             ch != '[' && ch != '\0'))
  256.         windex++;
  257.  
  258.     if (vbar) continue;
  259.  
  260.     else if (ch == endchar) break;
  261.  
  262.     else if (ch == ']') err_logo(UNEXPECTED_BRACKET, NIL);
  263.     else if (ch == '}') err_logo(UNEXPECTED_BRACE, NIL);
  264.  
  265.     /* if this is a '[', parse a new list */
  266.     else if (ch == '[') {
  267.         tnode = cons(parser_iterate(inln,inlimit,inhead,semi,']'), NIL);
  268.         if (**inln == '\0') ch = '\0';
  269.     }
  270.  
  271.     else if (ch == '{') {
  272.         tnode = cons(list_to_array
  273.              (parser_iterate(inln,inlimit,inhead,semi,'}')), NIL);
  274.         if (**inln == '@') {
  275.         int i = 0, sign = 1;
  276.  
  277.         (*inln)++;
  278.         if (**inln == '-') {
  279.             sign = -1;
  280.             (*inln)++;
  281.         }
  282.         while ((ch = **inln) >= '0' && ch <= '9') {
  283.             i = (i*10) + ch - '0';
  284.             (*inln)++;
  285.         }
  286.         setarrorg(car(tnode),sign*i);
  287.         }
  288.         if (**inln == '\0') ch = '\0';
  289.     }
  290.  
  291. /* if this character or the next one will terminate string, make the word */
  292.     else if (white_space(ch) || ch == '\0' ||
  293.          **inln == ']' || **inln == '[' ||
  294.          **inln == '{' || **inln == '}') {
  295.         if (windex > 0) {
  296.             if (broken == FALSE)
  297.              tnode = cons(make_strnode(wptr, inhead, windex,
  298.                            this_type, strnzcpy),
  299.                       NIL);
  300.             else {
  301.              tnode = cons(make_strnode(wptr, (char *)NULL, windex,
  302.                  this_type, (semi ? mend_strnzcpy : mend_nosemi)),
  303.                  NIL);
  304.              broken = FALSE;
  305.             }
  306.             this_type = STRING;
  307.             windex = 0;
  308.         }
  309.     }
  310.  
  311.     /* put the word onto the end of the return list */
  312.     if (tnode != NIL) {
  313.         if (outline == NIL) outline = vref(tnode);
  314.         else setcdr(lastnode, tnode);
  315.         lastnode = tnode;
  316.         tnode = NIL;
  317.     }
  318.     } while (ch);
  319.     return(unref(outline));
  320. }
  321.  
  322. NODE *parser(NODE *nd, BOOLEAN semi)
  323. {
  324.     NODE *rtn;
  325.     int slen;
  326.     char *lnsav;
  327.  
  328.     rtn = cnv_node_to_strnode(nd);
  329.     ref(rtn);
  330.     gcref(nd);
  331.     slen = getstrlen(rtn);
  332.     lnsav = getstrptr(rtn);
  333.     rtn = reref(rtn,
  334.         parser_iterate(&lnsav,lnsav + slen,getstrhead(rtn),semi,-1));
  335.     return(unref(rtn));
  336. }
  337.  
  338. NODE *lparse(NODE *args)
  339. {
  340.     NODE *arg, *val = UNBOUND;
  341.  
  342.     arg = string_arg(args);
  343.     if (NOT_THROWING) {
  344.     val = parser(arg, FALSE);
  345.     }
  346.     return(val);
  347. }
  348.  
  349. NODE *runparse_node(NODE *nd, NODE **ndsptr)
  350. {
  351.     NODE *outline = NIL, *tnode = NIL, *lastnode = NIL, *snd;
  352.     char *wptr, *tptr, *whead;
  353.     int wlen, wcnt, tcnt, isnumb;
  354.     NODETYPES wtyp;
  355.     BOOLEAN monadic_minus = FALSE;
  356.  
  357.     if (nd == Minus_Tight) return cons(nd, NIL);
  358.     snd = cnv_node_to_strnode(nd);
  359.     ref(snd);
  360.     wptr = getstrptr(snd);
  361.     wlen = getstrlen(snd);
  362.     wtyp = nodetype(snd);
  363.     wcnt = 0;
  364.     whead = getstrhead(snd);
  365.  
  366.     while (wcnt < wlen) {
  367.     if (*wptr == ';') {
  368.         *ndsptr = NIL;
  369.         break;
  370.     }
  371.     if (*wptr == '"') {
  372.         tcnt = 0;
  373.         tptr = ++wptr;
  374.         wcnt++;
  375.         while (wcnt < wlen && !parens(*wptr)) {
  376.         if (wtyp == BACKSLASH_STRING && getparity(*wptr))
  377.             wtyp = PUNBOUND;    /* flag for "\( case */
  378.         wptr++, wcnt++, tcnt++;
  379.         }
  380.         if (wtyp == PUNBOUND) {
  381.         wtyp = BACKSLASH_STRING;
  382.         tnode = cons(make_quote(intern(make_strnode(tptr, NULL,
  383.                     tcnt, wtyp, noparity_strnzcpy))), NIL);
  384.         } else
  385.         tnode = cons(make_quote(intern(make_strnode(tptr, whead, tcnt,
  386.                         wtyp, strnzcpy))), NIL);
  387.     } else if (*wptr == ':') {
  388.         tcnt = 0;
  389.         tptr = ++wptr;
  390.         wcnt++;
  391.         while (wcnt < wlen && !parens(*wptr) && !infixs(*wptr))
  392.         wptr++, wcnt++, tcnt++;
  393.         tnode = cons(make_colon(intern(make_strnode(tptr, whead, tcnt,
  394.                     wtyp, strnzcpy))), NIL);
  395.     } else if (wcnt == 0 && *wptr == '-' && monadic_minus == FALSE &&
  396.            !white_space(*(wptr+1))) {
  397.     /* minus sign with space before and no space after is unary */
  398.         tnode = cons(make_intnode((FIXNUM)0), NIL);
  399.         monadic_minus = TRUE;
  400.     } else if (parens(*wptr) || infixs(*wptr)) {
  401.         if (monadic_minus)
  402.         tnode = cons(Minus_Tight, NIL);
  403.         else
  404.         tnode = cons(intern(make_strnode(wptr, whead, 1,
  405.                          STRING, strnzcpy)), NIL);
  406.         monadic_minus = FALSE;
  407.         wptr++, wcnt++;
  408.     } else {
  409.         tcnt = 0;
  410.         tptr = wptr;
  411.         /* isnumb 0 means digits so far, 1 means just saw
  412.          * 'e' so minus can be next, 2 means no longer
  413.          * eligible even if an 'e' comes along */
  414.         isnumb = 0;
  415.         if (*wptr == '?') {
  416.         isnumb = 3; /* turn ?5 to (? 5) */
  417.         wptr++, wcnt++, tcnt++;
  418.         }
  419.         while (wcnt < wlen && !parens(*wptr) &&
  420.            (!infixs(*wptr) || (isnumb == 1 && *wptr == '-'))) {
  421.         if (isnumb == 0 && (*wptr == 'e' || *wptr == 'E'))
  422.             isnumb = 1;
  423.         else if (!(isdigit(*wptr) || *wptr == '.') || isnumb == 1)
  424.             isnumb = 2;
  425.         wptr++, wcnt++, tcnt++;
  426.         }
  427.         if (isnumb == 3 && tcnt > 1) {    /* ?5 syntax */
  428.         NODE *qmtnode;
  429.  
  430.         qmtnode = cons_list(0, Left_Paren, Query,
  431.                     cnv_node_to_numnode
  432.                     (make_strnode(tptr+1, whead,
  433.                               tcnt-1, wtyp, strnzcpy)),
  434.                     END_OF_LIST);
  435.         if (outline == NIL) {
  436.             outline = vref(qmtnode);
  437.         } else {
  438.             setcdr(lastnode, qmtnode);
  439.         }
  440.         lastnode = cddr(qmtnode);
  441.         tnode = cons(Right_Paren, NIL);
  442.         } else if (isnumb < 2 && tcnt > 0) {
  443.         tnode = cons(cnv_node_to_numnode(make_strnode(tptr, whead, tcnt,
  444.                                   wtyp, strnzcpy)),
  445.                  NIL);
  446.         } else
  447.         tnode = cons(intern(make_strnode(tptr, whead, tcnt,
  448.                          wtyp, strnzcpy)),
  449.                  NIL);
  450.     }
  451.  
  452.     if (outline == NIL) outline = vref(tnode);
  453.     else setcdr(lastnode, tnode);
  454.     lastnode = tnode;
  455.     }
  456.     deref(snd);
  457.     return(unref(outline));
  458. }
  459.  
  460. NODE *runparse(NODE *ndlist)
  461. {
  462.     NODE *curnd = NIL, *outline = NIL, *tnode = NIL, *lastnode = NIL;
  463.  
  464.     if (nodetype(ndlist) == RUN_PARSE)
  465.     return parsed__runparse(ndlist);
  466.     while (ndlist != NIL) {
  467.     curnd = car(ndlist);
  468.     ndlist = cdr(ndlist);
  469.     if (!is_word(curnd))
  470.         tnode = cons(curnd, NIL);
  471.     else {
  472.         if (!numberp(curnd))
  473.         tnode = runparse_node(curnd, &ndlist);
  474.         else
  475.         tnode = cons(cnv_node_to_numnode(curnd), NIL);
  476.     }
  477.     if (tnode != NIL) {
  478.         if (outline == NIL) outline = vref(tnode);
  479.         else setcdr(lastnode, tnode);
  480.         lastnode = tnode;
  481.         while (cdr(lastnode) != NIL) {
  482.         lastnode = cdr(lastnode);
  483.         if (check_throwing) break;
  484.         }
  485.     }
  486.     if (check_throwing) break;
  487.     }
  488.     return(unref(outline));
  489. }
  490.  
  491. NODE *lrunparse(NODE *args)
  492. {
  493.     NODE *arg;
  494.  
  495.     arg = car(args);
  496.     while (nodetype(arg) == ARRAY && NOT_THROWING) {
  497.     setcar(args, err_logo(BAD_DATA, arg));
  498.     arg = car(args);
  499.     }
  500.     if (NOT_THROWING && !aggregate(arg))
  501.     arg = parser(arg, TRUE);
  502.     if (NOT_THROWING)
  503.     return runparse(arg);
  504.     return UNBOUND;
  505. }
  506.